home *** CD-ROM | disk | FTP | other *** search
/ Especial Multimedia / Especial Multimedia.iso / Multimed / Prg / IMAGELIB.ZIP / MIMAGE.ZIP / REG_IM20.PAS < prev    next >
Pascal/Delphi Source File  |  1995-07-28  |  41KB  |  1,344 lines
  1. {add me to the delphi component library
  2.  
  3. Copyright 1995 by
  4. Kevin Adams, 74742,1444
  5. Jan Dekkers, 72130,353
  6.  
  7. }
  8.  
  9. {Part of Imagelib VCL/DLL Library.
  10.  
  11. Written by Jan Dekkers and Kevin Adams}
  12.  
  13.  
  14. unit Reg_im20;
  15.  
  16. interface
  17.  
  18. uses
  19.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms, Controls,
  20.   extctrls, StdCtrls, DLL20LIN, menus, DB, DBTables, Mask, Buttons;
  21.  
  22.  
  23. type
  24.   TMultiImage = class(TGraphicControl)
  25.   private
  26.     FPicture            : TPicture;
  27.     FAutoSize           : Boolean;
  28.     FStretch            : Boolean;
  29.     FCenter             : Boolean;
  30.     FReserved           : Byte;
  31.     FFilename           : TFileName;
  32.     Fdither             : byte;
  33.     FResolution         : byte;
  34.     FSaveQuality        : byte;
  35.     FSaveSmooth         : byte;
  36.     FSaveFileName       : TFileName;
  37.     Temps               : TFileName;
  38.     function GetCanvas: TCanvas;
  39.     procedure PictureChanged(Sender: TObject);
  40.     procedure SetAutoSize(Value: Boolean);
  41.     procedure SetCenter(Value: Boolean);
  42.     procedure SetPicture(Value: TPicture);
  43.     procedure SetStretch(Value: Boolean);
  44.   protected
  45.     function GetPalette: HPALETTE; override;
  46.   public
  47.     BFiletype           :  String;
  48.     Bwidth              :  Integer;
  49.     BHeight             :  Integer;
  50.     Bbitspixel          :  Integer;
  51.     Bplanes             :  Integer;
  52.     Bnumcolors          :  Integer;
  53.     BSize               :  Longint;
  54.     Bcompression        :  String;
  55.     constructor Create(AOwner: TComponent); override;
  56.     destructor Destroy; override;
  57.     property Canvas: TCanvas read GetCanvas;
  58.     function GetMultiBitmap : String;
  59.     Procedure WriteMultiName(Name : String);
  60.     procedure Paint; override;
  61.     function GetSmooth : Byte;
  62.     procedure SetSmooth(smooth : Byte);
  63.     function GetQuality : Byte;
  64.     procedure SetQuality(Quality : Byte);
  65.     function GetDither : Byte;
  66.     procedure SetDither(dith : Byte);
  67.     function GetRes : Byte;
  68.     procedure SetRes(res : Byte);
  69.     function GetSaveFileName : TFilename;
  70.     procedure SetSaveFileName(fn : TFilename);
  71.     procedure SaveAsJpg(FN : TFileName);
  72.     procedure SaveAsBMP(FN : TFileName);
  73.     function GetInfoAndType(filename : TFilename) : Boolean;
  74.   published
  75.     property Align;
  76.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  77.     property Center: Boolean read FCenter write SetCenter default False;
  78.     property DragCursor;
  79.     property DragMode;
  80.     property Enabled;
  81.     property JPegDither : Byte read GetDither write SetDither;
  82.     property JPegResolution : Byte read GetRes write SetRes;
  83.     property Picture: TPicture read FPicture write SetPicture;
  84.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  85.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  86.     property DefSaveFileName : TFileName read GetSaveFileName write SetSaveFileName;
  87.     property ImageName  : String read GetMultiBitmap write WriteMultiName;
  88.     property ParentShowHint;
  89.     property PopupMenu;
  90.     property ShowHint;
  91.     property Stretch: Boolean read FStretch write SetStretch default False;
  92.     property Visible;
  93.     property OnClick;
  94.     property OnDblClick;
  95.     property OnDragDrop;
  96.     property OnDragOver;
  97.     property OnEndDrag;
  98.     property OnMouseDown;
  99.     property OnMouseMove;
  100.     property OnMouseUp;
  101.   end;
  102.  
  103. { TDBMultiImage }
  104. Type
  105.   TDBMultiImage = class(TCustomControl)
  106.   private
  107.     FDataLink           :  TFieldDataLink;
  108.     FPicture            :  TPicture;
  109.     FBorderStyle        :  TBorderStyle;
  110.     FAutoDisplay        :  Boolean;
  111.     FStretch            :  Boolean;
  112.     FCenter             :  Boolean;
  113.     FPictureLoaded      :  Boolean;
  114.     FUpdateAsJpeg       :  Boolean;
  115.     FReserved           :  Byte;
  116.     Fdither             :  byte;
  117.     FResolution         :  byte;
  118.     FSaveQuality        :  byte;
  119.     FSaveSmooth         :  byte;
  120.     procedure DataChange(Sender: TObject);
  121.     function GetDataField: string;
  122.     function GetDataSource: TDataSource;
  123.     function GetField: TField;
  124.     function GetReadOnly: Boolean;
  125.     procedure PictureChanged(Sender: TObject);
  126.     procedure SetAutoDisplay(Value: Boolean);
  127.     procedure SetBorderStyle(Value: TBorderStyle);
  128.     procedure SetCenter(Value: Boolean);
  129.     procedure SetDataField(const Value: string);
  130.     procedure SetDataSource(Value: TDataSource);
  131.     procedure SetPicture(Value: TPicture);
  132.     procedure SetReadOnly(Value: Boolean);
  133.     procedure SetStretch(Value: Boolean);
  134.     procedure UpdateData(Sender: TObject);
  135.     procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  136.     procedure CMExit(var Message: TCMExit); message CM_EXIT;
  137.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  138.     procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
  139.     procedure WMCut(var Message: TMessage); message WM_CUT;
  140.     procedure WMCopy(var Message: TMessage); message WM_COPY;
  141.     procedure WMPaste(var Message: TMessage); message WM_PASTE;
  142.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  143.   protected
  144.     procedure CreateParams(var Params: TCreateParams); override;
  145.     function GetPalette: HPALETTE; override;
  146.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  147.     procedure KeyPress(var Key: Char); override;
  148.     procedure Notification(AComponent: TComponent;
  149.       Operation: TOperation); override;
  150.     procedure Paint; override;
  151.     function GetSmooth : Byte;
  152.     procedure SetSmooth(smooth : Byte);
  153.     function GetQuality : Byte;
  154.     procedure SetQuality(Quality : Byte);
  155.     function GetDither : Byte;
  156.     procedure SetDither(dith : Byte);
  157.     function GetRes : Byte;
  158.     procedure SetRes(res : Byte);
  159.   public
  160.     BFiletype           :  String;
  161.     Bwidth              :  Integer;
  162.     BHeight             :  Integer;
  163.     Bbitspixel          :  Integer;
  164.     Bplanes             :  Integer;
  165.     Bnumcolors          :  Integer;
  166.     BSize               :  Longint;
  167.     Bcompression        :  String;
  168.     constructor Create(AOwner: TComponent); override;
  169.     destructor Destroy; override;
  170.     procedure CopyToClipboard;
  171.     procedure CutToClipboard;
  172.     procedure LoadPicture;
  173.     procedure PasteFromClipboard;
  174.     procedure LoadFromFile(filename : TFilename);
  175.     procedure SaveToFile(filename : TFilename);
  176.     procedure SaveToFileAsBMP(filename : TFilename);
  177.     procedure SaveToFileAsJpeg(filename : TFilename);
  178.     function GetInfoAndType : String;
  179.     property Field: TField read GetField;
  180.     property Picture: TPicture read FPicture write SetPicture;
  181.   published
  182.     property JPegDither : Byte read GetDither write SetDither;
  183.     property JPegResolution : Byte read GetRes write SetRes;
  184.     property JPegSaveQuality : Byte read GetQuality write SetQuality;
  185.     property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
  186.     property UPdateBlobAsJpeg : Boolean read FUpdateAsJpeg write FUpdateAsJpeg;
  187.     property Align;
  188.     property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True;
  189.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  190.     property Center: Boolean read FCenter write SetCenter default True;
  191.     property Color;
  192.     property Ctl3D;
  193.     property DataField: string read GetDataField write SetDataField;
  194.     property DataSource: TDataSource read GetDataSource write SetDataSource;
  195.     property DragCursor;
  196.     property DragMode;
  197.     property Enabled;
  198.     property Font;
  199.     property ParentColor default False;
  200.     property ParentCtl3D;
  201.     property ParentFont;
  202.     property ParentShowHint;
  203.     property PopupMenu;
  204.     property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
  205.     property ShowHint;
  206.     property Stretch: Boolean read FStretch write SetStretch default False;
  207.     property TabOrder;
  208.     property TabStop default True;
  209.     property Visible;
  210.     property OnClick;
  211.     property OnDblClick;
  212.     property OnDragDrop;
  213.     property OnDragOver;
  214.     property OnEndDrag;
  215.     property OnEnter;
  216.     property OnExit;
  217.     property OnKeyDown;
  218.     property OnKeyPress;
  219.     property OnKeyUp;
  220.     property OnMouseDown;
  221.     property OnMouseMove;
  222.     property OnMouseUp;
  223.   end;
  224.  
  225.  
  226. procedure Register;
  227.  
  228. var
  229.  TMultiImageCallBack   : TCallBackFunction;
  230.  TDBMultiImageCallBack : TCallBackFunction;
  231.  
  232. {------------------------------------------------------------------------}
  233. implementation
  234. uses Consts, DBIErrs, DBITypes, Clipbrd, DBConsts, Dialogs;
  235.  
  236. {------------------------------------------------------------------------}
  237. procedure Register;
  238. begin
  239.   RegisterComponents('Add Ons',[TMultiImage]);
  240.   RegisterComponents('Add Ons',[TDBMultiImage]);
  241. end;
  242.  
  243. {------------------------------------------------------------------------
  244.  TMultiImage.
  245. ------------------------------------------------------------------------}
  246.  
  247.  
  248. constructor TMultiImage.Create(AOwner: TComponent);
  249. begin
  250.   inherited Create(AOwner);
  251.   FPicture := TPicture.Create;
  252.   FPicture.OnChange := PictureChanged;
  253.   FFilename:='';
  254.   Fdither:=4;
  255.   FResolution:=8;
  256.   FSaveQuality:=25;
  257.   FSaveSmooth:=0;
  258.   Picture.Graphic := nil;
  259.   Height := 105;
  260.   Width := 105;
  261.  end;
  262. {------------------------------------------------------------------------}
  263.  
  264.  
  265. destructor TMultiImage.Destroy;
  266. begin
  267.   FPicture.Free;
  268.   inherited Destroy;
  269. end;
  270. {------------------------------------------------------------------------}
  271.  
  272. function TMultiImage.GetPalette: HPALETTE;
  273. begin
  274.   Result := 0;
  275.   if FPicture.Graphic is TBitmap then
  276.     Result := TBitmap(FPicture.Graphic).Palette;
  277. end;
  278. {------------------------------------------------------------------------}
  279.  
  280. procedure TMultiImage.Paint;
  281. var
  282.   Dest: TRect;
  283. begin
  284.   if csDesigning in ComponentState then
  285.     with inherited Canvas do
  286.     begin
  287.       Pen.Style := psDash;
  288.       Brush.Style := bsClear;
  289.       Rectangle(0, 0, Width, Height);
  290.     end;
  291.   if Stretch then
  292.     Dest := ClientRect
  293.   else if Center then
  294.     Dest := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
  295.       Picture.Width, Picture.Height)
  296.   else
  297.     Dest := Rect(0, 0, Picture.Width, Picture.Height);
  298.   with inherited Canvas do
  299.     StretchDraw(Dest, Picture.Graphic);
  300. end;
  301. {------------------------------------------------------------------------}
  302.  
  303. function TMultiImage.GetCanvas: TCanvas;
  304. var
  305.   Bitmap: TBitmap;
  306. begin
  307.   if Picture.Graphic = nil then
  308.   begin
  309.     Bitmap := TBitmap.Create;
  310.     try
  311.       Bitmap.Width := Width;
  312.       Bitmap.Height := Height;
  313.       Picture.Graphic := Bitmap;
  314.     finally
  315.       Bitmap.Free;
  316.     end;
  317.   end;
  318.   if Picture.Graphic is TBitmap then
  319.     Result := TBitmap(Picture.Graphic).Canvas
  320.   else
  321.     raise EInvalidOperation.Create(LoadStr(SImageCanvasNeedsBitmap));
  322. end;
  323. {------------------------------------------------------------------------}
  324.  
  325. procedure TMultiImage.SetAutoSize(Value: Boolean);
  326. begin
  327.   FAutoSize := Value;
  328.   PictureChanged(Self);
  329. end;
  330. {------------------------------------------------------------------------}
  331.  
  332. procedure TMultiImage.SetCenter(Value: Boolean);
  333. begin
  334.   if FCenter <> Value then
  335.   begin
  336.     FCenter := Value;
  337.     Invalidate;
  338.   end;
  339. end;
  340. {------------------------------------------------------------------------}
  341.  
  342. procedure TMultiImage.SetPicture(Value: TPicture);
  343. begin
  344.   FPicture.Assign(Value);
  345. end;
  346. {------------------------------------------------------------------------}
  347.  
  348. procedure TMultiImage.SetStretch(Value: Boolean);
  349. begin
  350.   FStretch := Value;
  351.   Invalidate;
  352. end;
  353. {------------------------------------------------------------------------}
  354.  
  355. procedure TMultiImage.PictureChanged(Sender: TObject);
  356. begin
  357.   if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
  358.     SetBounds(Left, Top, Picture.Width, Picture.Height);
  359.   if (Picture.Graphic is TBitmap) and (Picture.Width = Width) and
  360.     (Picture.Height = Height) then
  361.     ControlStyle := ControlStyle + [csOpaque] else
  362.     ControlStyle := ControlStyle - [csOpaque];
  363.   Invalidate;
  364. end;
  365. {------------------------------------------------------------------------}
  366.  
  367. function TMultiImage.GetDither : Byte;
  368. begin
  369.   GetDither:=Fdither
  370. end;
  371. {------------------------------------------------------------------------}
  372.  
  373. procedure TMultiImage.SetDither(dith : Byte);
  374. begin
  375.   Fdither:=4;
  376.   case dith of
  377.             0..4 :Fdither:=dith;
  378.   end;
  379. end;
  380. {------------------------------------------------------------------------}
  381.  
  382. function TMultiImage.GetRes : Byte;
  383. begin
  384.   GetRes:=FResolution;
  385. end;
  386. {------------------------------------------------------------------------}
  387.  
  388.  
  389. procedure TMultiImage.SetRes(res : Byte);
  390. begin
  391.   FResolution:=8;
  392.   case res of
  393.             4 :FResolution:=res;
  394.             8 :FResolution:=res;
  395.             24 :FResolution:=res;
  396.   end;
  397. end;
  398. {------------------------------------------------------------------------}
  399.  
  400. Procedure TMultiImage.WriteMultiName(Name : String);
  401. begin
  402.   FFilename:=Name;
  403.   GetMultiBitmap;
  404. end;
  405. {------------------------------------------------------------------------}
  406.  
  407.  
  408. function TMultiImage.GetMultiBitmap :  String;
  409. var    bitmap     : TBitMap;
  410.        Pextension : string[4];
  411.        OnExcept   : Boolean;
  412.        f          : file of byte;
  413. label  BreakIt;
  414.  
  415. begin
  416.   OnExcept:=False;
  417.   if not FileExists(FFilename) then begin
  418.      Picture.Graphic := nil;
  419.      temps:='file not found';
  420.      GetMultiBitmap:=temps;
  421.      exit;
  422.   end;
  423.  
  424.   if FResolution <> 4 then if FResolution <> 8 then if FResolution <> 24 then
  425.    FResolution:=8;
  426.  
  427.   if (FDither < 0) or (FDither > 4) then FDither:=4;
  428.  
  429.   Pextension:=UpperCase(ExtractFileExt(FFilename));
  430.  
  431.   if (Pextension =  '.WMF') or (Pextension =  '.ICO') then begin
  432.     Picture.LoadFromFile(FFilename);
  433.     Temps:='Non JPeg, BMP, GIF or PCX Image';
  434.     GetMultiBitmap:=Temps;
  435.     GetInfoAndType(FFileName);
  436.     exit;
  437.   end;
  438.  
  439.  if (UpperCase(FFilename) = temps) and (Picture.Bitmap <> nil) then
  440.    Goto BreakIt;
  441.  
  442.  if Pextension = '.BMP' then begin
  443.     try
  444.      Bitmap := TBitmap.Create;
  445.      if not bmpfile(FFileName, Bitmap, TMultiImageCallBack) then
  446.        MessageDlg('Reading bmp file failed', mtInformation, [mbOk], 0);
  447.     except
  448.      Picture.Graphic := nil;
  449.      Bitmap.Free;
  450.      OnExcept:=True;
  451.     end;
  452.      if OnExcept then Goto BreakIt;
  453.      Picture.Graphic:=Bitmap;
  454.      Bitmap.Free;
  455.      GetInfoAndType(FFileName);
  456.  end;
  457.  
  458.  if Pextension = '.GIF' then begin
  459.     try
  460.      Bitmap := TBitmap.Create;
  461.      if not Giffile(FFileName, Bitmap, TMultiImageCallBack) then
  462.        MessageDlg('Reading gif file failed', mtInformation, [mbOk], 0);
  463.     except
  464.      Picture.Graphic := nil;
  465.      Bitmap.Free;
  466.      OnExcept:=True;
  467.     end;
  468.      if OnExcept then Goto BreakIt;
  469.      Picture.Graphic:=Bitmap;
  470.      Bitmap.Free;
  471.      GetInfoAndType(FFileName);
  472.  end;
  473.  
  474.  if Pextension = '.PCX' then begin
  475.     try
  476.      Bitmap := TBitmap.Create;
  477.      if not PCXfile(FFileName, Bitmap, TMultiImageCallBack) then
  478.        MessageDlg('Reading pcx file failed', mtInformation, [mbOk], 0);
  479.     except
  480.      Picture.Graphic := nil;
  481.      Bitmap.Free;
  482.      OnExcept:=True;
  483.     end;
  484.      if OnExcept then Goto BreakIt;
  485.      Picture.Graphic:=Bitmap;
  486.      Bitmap.Free;
  487.      GetInfoAndType(FFileName);
  488.  end;
  489.  
  490.  if Pextension = '.JPG' then begin
  491.     try
  492.      Bitmap := TBitmap.Create;
  493.      if not jpgfile(FFilename, FResolution, Fdither, Bitmap, TMultiImageCallBack) then
  494.        MessageDlg('Reading jpg file failed', mtInformation, [mbOk], 0);
  495.     except
  496.      Picture.Graphic := nil;
  497.      Bitmap.Free;
  498.      OnExcept:=True;
  499.     end;
  500.      if OnExcept then Goto BreakIt;
  501.      Picture.Graphic:=Bitmap;
  502.      Bitmap.Free;
  503.      GetInfoAndType(FFileName);
  504.  end;
  505.  
  506.  BreakIt:
  507.  Temps:=UpperCase(FFilename);
  508.  GetMultiBitmap:=Temps;
  509. end;
  510. {------------------------------------------------------------------------}
  511.  
  512. function TMultiImage.GetSmooth : Byte;
  513. begin
  514.   GetSmooth:=FSaveSmooth;
  515. end;
  516. {------------------------------------------------------------------------}
  517.  
  518. procedure TMultiImage.SetSmooth(Smooth : Byte);
  519. begin
  520.   if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  521.    FSaveSmooth:=Smooth;
  522. end;
  523. {------------------------------------------------------------------------}
  524.  
  525. function TMultiImage.GetQuality : Byte;
  526. begin
  527.   GetQuality:=FSaveQuality;
  528. end;
  529. {------------------------------------------------------------------------}
  530.  
  531. procedure TMultiImage.SetQuality(Quality : Byte);
  532. begin
  533.   if (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
  534.    FSaveQuality:=Quality;
  535. end;
  536. {------------------------------------------------------------------------}
  537.  
  538. function TMultiImage.GetSaveFileName : TFilename;
  539. begin
  540.   GetSaveFileName:=FSaveFileName;
  541. end;
  542. {------------------------------------------------------------------------}
  543.  
  544. procedure TMultiImage.SetSaveFileName(fn : TFilename);
  545. begin
  546.  if fn <> '' then
  547.    FSaveFileName:=fn
  548.  else
  549.    FSaveFileName:='';
  550. end;
  551.  
  552.  
  553. {------------------------------------------------------------------------}
  554. procedure TMultiImage.SaveAsBMP(FN : TFileName);
  555. begin
  556.    if fn <> '' then FSaveFileName:=fn;
  557.   try
  558.     if not putbmpfile(FSaveFileName, picture.Bitmap, TMultiImageCallBack) then
  559.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  560.   except
  561.  
  562.   end;
  563. end;
  564.  
  565. {------------------------------------------------------------------------}
  566.  
  567. procedure TMultiImage.SaveAsJpg(FN : TFileName);
  568. begin
  569.    if fn <> '' then FSaveFileName:=fn;
  570.   try
  571.    if not putjpgfile(FSaveFileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TMultiImageCallBack) then
  572.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  573.   except
  574.  
  575.   end;
  576. end;
  577.  
  578. {------------------------------------------------------------------------}
  579. function TMultiImage.GetInfoAndType(filename : TFilename) : Boolean;
  580. var
  581.   Pextension : string[4];
  582.   f          : file of byte;
  583. begin
  584.   Pextension:=UpperCase(ExtractFileExt(Filename));
  585.   if (Pextension =  '.WMF') or (Pextension =  '.ICO') then begin
  586.    if fileexists(Filename) then begin
  587.     Delete(Pextension,1,1);
  588.     BFiletype           := Pextension;
  589.     Bwidth              := Picture.width;
  590.     BHeight             := Picture.Height;
  591.     Bbitspixel          := 0;
  592.     Bplanes             := 0;
  593.     Bnumcolors          := 0;
  594.     Bcompression        := Pextension;
  595.     AssignFile(f, FFileName);
  596.     Reset(f);
  597.     Bsize := FileSize(f);
  598.     CloseFile(f);
  599.     GetInfoAndType:=true;
  600.     exit;
  601.    end else begin
  602.     BFiletype           := 'ERR';
  603.     Bwidth              := -1;
  604.     BHeight             := -1;
  605.     Bbitspixel          := -1;
  606.     Bplanes             := -1;
  607.     Bnumcolors          := -1;
  608.     Bcompression        := 'ERR';
  609.     Bsize               := -1;
  610.     GetInfoAndType      := false;
  611.     exit;
  612.    end;
  613.   end;
  614.   GetInfoAndType:=GetFileInfo(filename,
  615.                               BFileType,
  616.                               Bwidth,
  617.                               BHeight,
  618.                               Bbitspixel,
  619.                               Bplanes,
  620.                               Bnumcolors,
  621.                               Bcompression);
  622.    AssignFile(f, FileName);
  623.    Reset(f);
  624.    Bsize := FileSize(f);
  625.    CloseFile(f);
  626.  end;
  627.  
  628. {------------------------------------------------------------------------
  629. end TMultiImage
  630. ------------------------------------------------------------------------}
  631.  
  632. {TDBMultiImage}
  633. constructor TDBMultiImage.Create(AOwner: TComponent);
  634. begin
  635.   inherited Create(AOwner);
  636.   ControlStyle := ControlStyle + [csFramed, csOpaque];
  637.   Width := 105;
  638.   Height := 105;
  639.   TabStop := True;
  640.   ParentColor := False;
  641.   FPicture := TPicture.Create;
  642.   FPicture.OnChange := PictureChanged;
  643.   FBorderStyle := bsSingle;
  644.   FAutoDisplay := True;
  645.   FCenter := True;
  646.   FUpdateAsJpeg := True;
  647.   Fdither:=4;
  648.   FResolution:=8;
  649.   FSaveQuality:=25;
  650.   FSaveSmooth:=0;
  651.   FDataLink := TFieldDataLink.Create;
  652.   FDataLink.Control := Self;
  653.   FDataLink.OnDataChange := DataChange;
  654.   FDataLink.OnUpdateData := UpdateData;
  655. end;
  656. {------------------------------------------------------------------------}
  657.  
  658. destructor TDBMultiImage.Destroy;
  659. begin
  660.   FPicture.Free;
  661.   FDataLink.Free;
  662.   FDataLink := nil;
  663.   inherited Destroy;
  664. end;
  665. {------------------------------------------------------------------------}
  666.  
  667. function TDBMultiImage.GetDataSource: TDataSource;
  668. begin
  669.   Result := FDataLink.DataSource;
  670. end;
  671. {------------------------------------------------------------------------}
  672.  
  673. procedure TDBMultiImage.SetDataSource(Value: TDataSource);
  674. begin
  675.   FDataLink.DataSource := Value;
  676. end;
  677. {------------------------------------------------------------------------}
  678.  
  679. function TDBMultiImage.GetDataField: string;
  680. begin
  681.   Result := FDataLink.FieldName;
  682. end;
  683. {------------------------------------------------------------------------}
  684.  
  685. procedure TDBMultiImage.SetDataField(const Value: string);
  686. begin
  687.   FDataLink.FieldName := Value;
  688. end;
  689. {------------------------------------------------------------------------}
  690.  
  691. function TDBMultiImage.GetReadOnly: Boolean;
  692. begin
  693.   Result := FDataLink.ReadOnly;
  694. end;
  695. {------------------------------------------------------------------------}
  696.  
  697. procedure TDBMultiImage.SetReadOnly(Value: Boolean);
  698. begin
  699.   FDataLink.ReadOnly := Value;
  700. end;
  701. {------------------------------------------------------------------------}
  702.  
  703. function TDBMultiImage.GetField: TField;
  704. begin
  705.   Result := FDataLink.Field;
  706. end;
  707. {------------------------------------------------------------------------}
  708.  
  709. function TDBMultiImage.GetPalette: HPALETTE;
  710. begin
  711.   Result := 0;
  712.   if FPicture.Graphic is TBitmap then
  713.     Result := TBitmap(FPicture.Graphic).Palette;
  714. end;
  715. {------------------------------------------------------------------------}
  716.  
  717. procedure TDBMultiImage.SetAutoDisplay(Value: Boolean);
  718. begin
  719.   if FAutoDisplay <> Value then
  720.   begin
  721.     FAutoDisplay := Value;
  722.     if Value then LoadPicture;
  723.   end;
  724. end;
  725. {------------------------------------------------------------------------}
  726.  
  727. procedure TDBMultiImage.SetBorderStyle(Value: TBorderStyle);
  728. begin
  729.   if FBorderStyle <> Value then
  730.   begin
  731.     FBorderStyle := Value;
  732.     RecreateWnd;
  733.   end;
  734. end;
  735. {------------------------------------------------------------------------}
  736.  
  737. procedure TDBMultiImage.SetCenter(Value: Boolean);
  738. begin
  739.   if FCenter <> Value then
  740.   begin
  741.     FCenter := Value;
  742.     Invalidate;
  743.   end;
  744. end;
  745. {------------------------------------------------------------------------}
  746.  
  747. procedure TDBMultiImage.SetPicture(Value: TPicture);
  748. begin
  749.   FPicture.Assign(Value);
  750. end;
  751. {------------------------------------------------------------------------}
  752.  
  753. procedure TDBMultiImage.SetStretch(Value: Boolean);
  754. begin
  755.   if FStretch <> Value then
  756.   begin
  757.     FStretch := Value;
  758.     Invalidate;
  759.   end;
  760. end;
  761. {------------------------------------------------------------------------}
  762.  
  763. procedure TDBMultiImage.Paint;
  764. var
  765.   W, H: Integer;
  766.   R: TRect;
  767.   S: string[63];
  768. begin
  769.   with Canvas do
  770.   begin
  771.     Brush.Style := bsSolid;
  772.     Brush.Color := Color;
  773.     if FPictureLoaded then
  774.     begin
  775.       if Stretch then
  776.         if Picture.Graphic.Empty then
  777.           FillRect(ClientRect) else
  778.           StretchDraw(ClientRect, Picture.Graphic)
  779.       else
  780.       begin
  781.         SetRect(R, 0, 0, Picture.Width, Picture.Height);
  782.         if Center then OffsetRect(R, (ClientWidth - Picture.Width) div 2,
  783.           (ClientHeight - Picture.Height) div 2);
  784.         StretchDraw(R, Picture.Graphic);
  785.         ExcludeClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
  786.         FillRect(ClientRect);
  787.         SelectClipRgn(Handle, 0);
  788.       end;
  789.     end else
  790.     begin
  791.       Font := Self.Font;
  792.       if FDataLink.Field <> nil then
  793.         S := FDataLink.Field.DisplayLabel else
  794.         S := Name;
  795.       S := '(' + S + ')';
  796.       W := TextWidth(S);
  797.       H := TextHeight(S);
  798.       R := ClientRect;
  799.       TextRect(R, (R.Right - W) div 2, (R.Bottom - H) div 2, S);
  800.     end;
  801.     if (GetParentForm(Self).ActiveControl = Self) and
  802.       not (csDesigning in ComponentState) then
  803.     begin
  804.       Brush.Color := clWindowFrame;
  805.       FrameRect(ClientRect);
  806.     end;
  807.   end;
  808. end;
  809. {------------------------------------------------------------------------}
  810.  
  811. procedure TDBMultiImage.PictureChanged(Sender: TObject);
  812. begin
  813.   FDataLink.Modified;
  814.   FPictureLoaded := True;
  815.   Invalidate;
  816. end;
  817. {------------------------------------------------------------------------}
  818.  
  819. procedure TDBMultiImage.Notification(AComponent: TComponent;
  820.   Operation: TOperation);
  821. begin
  822.   inherited Notification(AComponent, Operation);
  823.   if (Operation = opRemove) and (FDataLink <> nil) and
  824.     (AComponent = DataSource) then DataSource := nil;
  825. end;
  826. {------------------------------------------------------------------------}
  827.  
  828. procedure TDBMultiImage.LoadPicture;
  829. var
  830.    Stream       :  TMemoryStream;
  831.    BitMap       :  TBitMap;
  832.    Cursor       :  hCursor;
  833.    temp         :  string;
  834. begin
  835.   if not FPictureLoaded and (FDataLink.Field is TBlobField) then begin
  836.  
  837.    if TBlobField(FDataLink.Field).IsNull then exit;
  838.  
  839.    Temp:=GetInfoAndType;
  840.  
  841.    SendMessage(Canvas.Handle, WM_Paint, 0, 0);
  842.  
  843.  
  844.    if Temp = 'GIF' then begin
  845.       Stream:=TMemoryStream.Create;
  846.       BitMap:=TBitMap.Create;
  847.       try
  848.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  849.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  850.          if not gifblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  851.             MessageDlg('Invallid or empty GIF blobfield', mtInformation, [mbOk], 0);
  852.             Picture.Assign(Nil);
  853.          end else
  854.             Picture.Assign(BitMap);
  855.          finally
  856.             SetCursor(Cursor);
  857.             BitMap.free;
  858.             Stream.Free;
  859.          end;
  860.    end else
  861.    if Temp = 'PCX' then begin
  862.       Stream:=TMemoryStream.Create;
  863.       BitMap:=TBitMap.Create;
  864.       try
  865.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  866.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  867.          if not pcxblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  868.             MessageDlg('Invallid or empty PCX blobfield', mtInformation, [mbOk], 0);
  869.             Picture.Assign(Nil);
  870.          end else
  871.             Picture.Assign(BitMap);
  872.          finally
  873.           SetCursor(Cursor);
  874.           BitMap.free;
  875.           Stream.Free;
  876.          end;
  877.    end else
  878.    if Temp = 'BMP' then begin
  879.       Stream:=TMemoryStream.Create;
  880.       BitMap:=TBitMap.Create;
  881.       try
  882.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  883.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  884.          if not bmpblob(Stream.Memory,Stream.Size, Bitmap, TDBMultiImageCallBack) then begin
  885.             MessageDlg('Invallid or empty BMP blobfield', mtInformation, [mbOk], 0);
  886.             Picture.Assign(Nil);
  887.          end else
  888.             Picture.Assign(BitMap);
  889.          finally
  890.           SetCursor(Cursor);
  891.           BitMap.free;
  892.           Stream.Free;
  893.          end;
  894.    end else
  895.    if Temp = 'JPG' then begin
  896.       Stream:=TMemoryStream.Create;
  897.       BitMap:=TBitMap.Create;
  898.       if FResolution <> 4 then
  899.       if FResolution <> 8 then
  900.       if FResolution <> 24 then FResolution:=8;
  901.       if (FDither < 0) or (FDither > 4) then FDither:=4;
  902.       try
  903.          TBlobField(FDataLink.Field).SaveToStream(Stream);
  904.          Cursor := SetCursor(LoadCursor(0,idc_Wait));
  905.          if not jpgblob(Stream.Memory,Stream.Size, FResolution, Fdither, Bitmap, TDBMultiImageCallBack) then begin
  906.             MessageDlg('Invallid or empty Jpeg Blobfield', mtInformation, [mbOk], 0);
  907.             Picture.Assign(Nil);
  908.          end else
  909.              Picture.Assign(BitMap);
  910.          finally
  911.              SetCursor(Cursor);
  912.              BitMap.free;
  913.              Stream.Free;
  914.          end;
  915.     end;
  916.     GetInfoAndType;
  917.  end;
  918. end;
  919. {------------------------------------------------------------------------}
  920.  
  921. procedure TDBMultiImage.DataChange(Sender: TObject);
  922. begin
  923.   Picture.Graphic := nil;
  924.   FPictureLoaded := False;
  925.   if FAutoDisplay then LoadPicture;
  926. end;
  927. {------------------------------------------------------------------------}
  928.  
  929. procedure TDBMultiImage.UpdateData(Sender: TObject);
  930. var
  931.    Stream       :  TMemoryStream;
  932.    Cursor       :  hCursor;
  933.    Usize        :  longInt;
  934.    x,y          :  longInt;
  935.    p            :  Pointer;
  936. begin
  937.   if FDataLink.Field is TBlobField then begin
  938.  
  939.     if Picture.Graphic is TBitmap then begin
  940.       x:=Picture.BitMap.Width;
  941.       y:=Picture.BitMap.Height;
  942.  
  943.       y:=y+(y div 5);
  944.       x:=x+(x div 5);
  945.  
  946.       Usize:=(y * x);
  947.  
  948.       if Usize < 90000 then Usize:=Usize*2;
  949.  
  950.       {Since we can't know how much memory we need to allocate
  951.       to write the picture to the stream we need to guess it. This
  952.       is done using the width and height of the bitmap. After the call
  953.       to the dll using PUTJPGBLOB or PUTBMPBLOB Usize contains the
  954.       correct size of the Jpeg stored in P^. You can increase or decrease
  955.       the guessed memory by altering the Div by. For instance
  956.  
  957.       y:=y+(y div 3);
  958.       x:=x+(x div 3);
  959.  
  960.       will allocate more memory then
  961.  
  962.       y:=y+(y div 6);
  963.       x:=x+(x div 6);
  964.  
  965.       We played it on the save side. Use this "guess work" very carefully}
  966.  
  967.  
  968.       P := GlobalAllocPtr(HeapAllocFlags, Usize);
  969.       if P = Nil then begin
  970.         MessageDlg('Error allocation blob memory', mtInformation, [mbOk], 0);
  971.         exit;
  972.       end;
  973.  
  974.       if FUpdateAsJpeg then begin
  975.          if not putjpgblob(P, USize, FSaveQuality, FSaveSmooth, Picture.Bitmap, TDBMultiImageCallBack) then
  976.            MessageDlg('Jpeg BLOB Write Error', mtInformation, [mbOk], 0);
  977.       end else begin
  978.          if not putbmpblob(P, USize, Picture.Bitmap, TDBMultiImageCallBack) then
  979.            MessageDlg('BMP BLOB Write Error', mtInformation, [mbOk], 0);
  980.       end;
  981.  
  982.       Stream:=TMemoryStream.Create;
  983.       Stream.Write(P^,USize);
  984.       GlobalFreePtr(P);
  985.  
  986.       try
  987.         TBlobField(FDataLink.Field).LoadFromStream(Stream);
  988.       finally
  989.         Stream.Free;
  990.       end;
  991.  
  992.     end else
  993.       TBlobField(FDataLink.Field).Clear;
  994.    end;
  995.    GetInfoAndType;
  996. end;
  997. {------------------------------------------------------------------------}
  998.  
  999. procedure TDBMultiImage.CopyToClipboard;
  1000. begin
  1001.   if Picture.Graphic <> nil then Clipboard.Assign(Picture);
  1002. end;
  1003. {------------------------------------------------------------------------}
  1004.  
  1005. procedure TDBMultiImage.CutToClipboard;
  1006. begin
  1007.   if Picture.Graphic <> nil then
  1008.   begin
  1009.     CopyToClipboard;
  1010.     if FDataLink.Edit then
  1011.       Picture.Graphic := nil;
  1012.   end;
  1013. end;
  1014. {------------------------------------------------------------------------}
  1015.  
  1016. procedure TDBMultiImage.PasteFromClipboard;
  1017. begin
  1018.   if Clipboard.HasFormat(CF_PICTURE) and FDataLink.Edit then
  1019.     Picture.Assign(Clipboard);
  1020. end;
  1021. {------------------------------------------------------------------------}
  1022.  
  1023. procedure TDBMultiImage.CreateParams(var Params: TCreateParams);
  1024. begin
  1025.   inherited CreateParams(Params);
  1026.   if FBorderStyle = bsSingle then
  1027.     Params.Style := Params.Style or WS_BORDER;
  1028. end;
  1029. {------------------------------------------------------------------------}
  1030.  
  1031. procedure TDBMultiImage.KeyDown(var Key: Word; Shift: TShiftState);
  1032. begin
  1033.   inherited KeyDown(Key, Shift);
  1034.   case Key of
  1035.     VK_INSERT:
  1036.       if ssShift in Shift then PasteFromClipBoard else
  1037.         if ssCtrl in Shift then CopyToClipBoard;
  1038.     VK_DELETE:
  1039.       if ssShift in Shift then CutToClipBoard;
  1040.   end;
  1041. end;
  1042. {------------------------------------------------------------------------}
  1043.  
  1044. procedure TDBMultiImage.KeyPress(var Key: Char);
  1045. begin
  1046.   inherited KeyPress(Key);
  1047.   case Key of
  1048.     ^X: CutToClipBoard;
  1049.     ^C: CopyToClipBoard;
  1050.     ^V: PasteFromClipBoard;
  1051.     #13: LoadPicture;
  1052.     #27: FDataLink.Reset;
  1053.   end;
  1054. end;
  1055. {------------------------------------------------------------------------}
  1056.  
  1057. procedure TDBMultiImage.CMEnter(var Message: TCMEnter);
  1058. begin
  1059.   Invalidate; { Draw the focus marker }
  1060.   inherited;
  1061. end;
  1062. {------------------------------------------------------------------------}
  1063.  
  1064. procedure TDBMultiImage.CMExit(var Message: TCMExit);
  1065. begin
  1066.   Invalidate; { Erase the focus marker }
  1067.   inherited;
  1068. end;
  1069. {------------------------------------------------------------------------}
  1070.  
  1071. procedure TDBMultiImage.CMTextChanged(var Message: TMessage);
  1072. begin
  1073.   inherited;
  1074.   if not FPictureLoaded then Invalidate;
  1075. end;
  1076. {------------------------------------------------------------------------}
  1077.  
  1078. procedure TDBMultiImage.WMLButtonDown(var Message: TWMLButtonDown);
  1079. begin
  1080.   if TabStop and CanFocus then SetFocus;
  1081.   inherited;
  1082. end;
  1083. {------------------------------------------------------------------------}
  1084.  
  1085. procedure TDBMultiImage.WMLButtonDblClk(var Message: TWMLButtonDblClk);
  1086. begin
  1087.   LoadPicture;
  1088.   inherited;
  1089. end;
  1090. {------------------------------------------------------------------------}
  1091.  
  1092. procedure TDBMultiImage.WMCut(var Message: TMessage);
  1093. begin
  1094.   CutToClipboard;
  1095. end;
  1096. {------------------------------------------------------------------------}
  1097.  
  1098. procedure TDBMultiImage.WMCopy(var Message: TMessage);
  1099. begin
  1100.   CopyToClipboard;
  1101. end;
  1102. {------------------------------------------------------------------------}
  1103.  
  1104. procedure TDBMultiImage.WMPaste(var Message: TMessage);
  1105. begin
  1106.   PasteFromClipboard;
  1107. end;
  1108. {------------------------------------------------------------------------}
  1109.  
  1110. procedure TDBMultiImage.LoadFromFile(filename : TFilename);
  1111. var
  1112.    Cursor       :  hCursor;
  1113. begin
  1114.  
  1115.   if not FileExists(filename) then begin
  1116.     MessageDlg('File not found', mtInformation, [mbOk], 0);
  1117.     exit;
  1118.   end;
  1119.  
  1120.   if UpperCase(ExtractFileExt(filename)) <> '.JPG' then
  1121.   if UpperCase(ExtractFileExt(filename)) <> '.GIF' then
  1122.   if UpperCase(ExtractFileExt(filename)) <> '.PCX' then
  1123.   if UpperCase(ExtractFileExt(filename)) <> '.BMP' then
  1124.   begin
  1125.     MessageDlg('Not a Jpeg, Gif, Pcx or Bmp File', mtInformation, [mbOk], 0);
  1126.     exit;
  1127.   end;
  1128.  
  1129.   Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1130.  
  1131.   if FDataLink.Field is TBlobField then
  1132.     TBlobField(FDataLink.Field).LoadFromFile(filename)
  1133.   else begin
  1134.     SetCursor(Cursor);
  1135.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1136.     exit;
  1137.   end;
  1138.   GetInfoAndType;
  1139.   SetCursor(Cursor);
  1140. end;
  1141. {------------------------------------------------------------------------}
  1142.  
  1143. procedure TDBMultiImage.SaveToFile(filename : TFilename);
  1144. var
  1145.   Cursor       :  hCursor;
  1146. begin
  1147.   if FDataLink.Field is TBlobField then begin
  1148.  
  1149.     if TBlobField(FDataLink.Field).IsNull then begin
  1150.        MessageDlg('Can''t save, blobfield is empty', mtInformation, [mbOk], 0);
  1151.        exit;
  1152.     end;
  1153.  
  1154.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1155.     TBlobField(FDataLink.Field).SaveToFile(filename);
  1156.     GetInfoAndType;
  1157.     SetCursor(Cursor)
  1158.  
  1159.   end else begin
  1160.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1161.     exit;
  1162.   end;
  1163. end;
  1164. {------------------------------------------------------------------------}
  1165.  
  1166. procedure TDBMultiImage.SaveToFileAsBMP(filename : TFilename);
  1167. var
  1168.   Cursor       :  hCursor;
  1169. begin
  1170.   if FDataLink.Field is TBlobField then begin
  1171.  
  1172.     if TBlobField(FDataLink.Field).IsNull then begin
  1173.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  1174.        exit;
  1175.     end;
  1176.  
  1177.     if picture.bitmap.empty then begin
  1178.        MessageDlg('Can''t save, image is not displayed, Set Autodisplay or double click display to view image first.',
  1179.                   mtInformation, [mbOk], 0);
  1180.        exit;
  1181.     end;
  1182.  
  1183.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1184.  
  1185.     if not putbmpfile(FileName, picture.Bitmap, TDBMultiImageCallBack) then begin
  1186.       SetCursor(Cursor);
  1187.       MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  1188.       exit;
  1189.     end;
  1190.  
  1191.     GetInfoAndType
  1192.  
  1193.   end else begin
  1194.     SetCursor(Cursor);
  1195.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1196.     exit;
  1197.   end;
  1198.  
  1199.   SetCursor(Cursor);
  1200. end;
  1201. {------------------------------------------------------------------------}
  1202.  
  1203. procedure TDBMultiImage.SaveToFileAsJpeg(filename : TFilename);
  1204. var
  1205.   Cursor       :  hCursor;
  1206. begin
  1207.   if FDataLink.Field is TBlobField then begin
  1208.  
  1209.     if TBlobField(FDataLink.Field).IsNull then begin
  1210.        MessageDlg('Can''t save, blobfield bitmap is empty', mtInformation, [mbOk], 0);
  1211.        exit;
  1212.     end;
  1213.  
  1214.     if picture.bitmap = nil then begin
  1215.        MessageDlg('Can''t save, image is not displayed', mtInformation, [mbOk], 0);
  1216.        exit;
  1217.     end;
  1218.  
  1219.     Cursor := SetCursor(LoadCursor(0,idc_Wait));
  1220.  
  1221.     if not putjpgfile(FileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TDBMultiImageCallBack) then begin
  1222.       SetCursor(Cursor);
  1223.       MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  1224.       exit;
  1225.     end;
  1226.  
  1227.     GetInfoAndType
  1228.  
  1229.   end else begin
  1230.     SetCursor(Cursor);
  1231.     MessageDlg('Field is not a blobfield', mtInformation, [mbOk], 0);
  1232.     exit;
  1233.   end;
  1234.  
  1235.   SetCursor(Cursor);
  1236. end;
  1237.  
  1238.  
  1239. {------------------------------------------------------------------------}
  1240.  
  1241. function TDBMultiImage.GetInfoAndType : String;
  1242. var
  1243.  Stream       :  TMemoryStream;
  1244. begin
  1245.   if (FDataLink.Field is TBlobField) then
  1246.    if TBlobField(FDataLink.Field).IsNull then exit;
  1247.  
  1248.    BFileType := 'Empty';
  1249.    Bwidth:=-1;
  1250.    BHeight:=-1;
  1251.    Bbitspixel:=-1;
  1252.    Bplanes:=-1;
  1253.    Bnumcolors:=-1;
  1254.    Bcompression:='-1';
  1255.    BSize:=-1;
  1256.    GetInfoAndType :='-1';
  1257.  
  1258.    Stream:=TMemoryStream.Create;
  1259.    TBlobField(FDataLink.Field).SaveToStream(Stream);
  1260.    if not GetBlobInfo(Stream.Memory,
  1261.                     Stream.Size,
  1262.                     BFileType,
  1263.                     Bwidth,
  1264.                     BHeight,
  1265.                     Bbitspixel,
  1266.                     Bplanes,
  1267.                     Bnumcolors,
  1268.                     Bcompression) then
  1269.     MessageDlg('blobfield getinfo failed', mtInformation, [mbOk], 0) else
  1270.     begin
  1271.          BSize:=Stream.Size;
  1272.          if UpperCase(BFileType) = 'GIF' then GetInfoAndType:='GIF' else
  1273.          if UpperCase(BFileType) = 'PCX' then GetInfoAndType:='PCX' else
  1274.          if UpperCase(BFileType) = 'JPEG' then GetInfoAndType:='JPG' else
  1275.          if UpperCase(BFileType) = 'BMP' then GetInfoAndType:='BMP';
  1276.     end;
  1277.   if Stream.Memory <> nil then Stream.Free;
  1278. end;
  1279. {------------------------------------------------------------------------}
  1280.  
  1281. function TDBMultiImage.GetSmooth : Byte;
  1282. begin
  1283.   GetSmooth:=FSaveSmooth;
  1284. end;
  1285. {------------------------------------------------------------------------}
  1286.  
  1287. procedure TDBMultiImage.SetSmooth(Smooth : Byte);
  1288. begin
  1289.   if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
  1290.    FSaveSmooth:=Smooth;
  1291. end;
  1292. {------------------------------------------------------------------------}
  1293.  
  1294. function TDBMultiImage.GetQuality : Byte;
  1295. begin
  1296.   GetQuality:=FSaveQuality;
  1297. end;
  1298. {------------------------------------------------------------------------}
  1299.  
  1300. procedure TDBMultiImage.SetQuality(Quality : Byte);
  1301. begin
  1302.   if (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
  1303.    FSaveQuality:=Quality;
  1304. end;
  1305. {------------------------------------------------------------------------}
  1306. function TDBMultiImage.GetDither : Byte;
  1307. begin
  1308.   GetDither:=Fdither
  1309. end;
  1310. {------------------------------------------------------------------------}
  1311.  
  1312. procedure TDBMultiImage.SetDither(dith : Byte);
  1313. begin
  1314.   Fdither:=4;
  1315.   case dith of
  1316.             0..4 :Fdither:=dith;
  1317.   end;
  1318. end;
  1319. {------------------------------------------------------------------------}
  1320.  
  1321. function TDBMultiImage.GetRes : Byte;
  1322. begin
  1323.   GetRes:=FResolution;
  1324. end;
  1325. {------------------------------------------------------------------------}
  1326.  
  1327.  
  1328. procedure TDBMultiImage.SetRes(res : Byte);
  1329. begin
  1330.   FResolution:=8;
  1331.   case res of
  1332.             4 :FResolution:=res;
  1333.             8 :FResolution:=res;
  1334.             24:FResolution:=res;
  1335.   end;
  1336. end;
  1337. {------------------------------------------------------------------------}
  1338.  
  1339. begin
  1340.  TMultiImageCallBack:=nil;
  1341.  TDBMultiImageCallBack:=nil;
  1342. end.
  1343.  
  1344.